;;Chapter 4 
;Page 42 - find-if and some utility
;(defun find2 (fn lst)
;  (if (null lst)
;    (values nil nil)
;    (some #'(lambda (town)
;              (let ((shops (bookshops town)))
;                (if shops
;                  (values town shops))))
;          lst)))

;Page 44; Utilities - longer
(defun longer (lst1 lst2)
  (if (and (null (car lst2)) (car lst1))
    t
    (and (cdr lst1) 
         (longer (cdr lst1) 
                 (cdr lst2)))))
    
;Page 44; Utilities - Longer PG's implementation
(defun longer1 (x y)
  (labels ((compare (x y)
                    (and (consp x)
                         (or (null y)
                             (compare (cdr x) (cdr y))))))
    (if (and (listp x) (listp y))
      (compare x y)
      (> (length x) (length y)))))

;Page 47; Utilities on List, filter
;when to stop - when lst is null 
;what to return - acc
;first step - get some from lst add to acc
;next step -   filter on cdr lst 
(defun filter (fn lst)
  (labels ((rec (fn lst)
                (if lst
                  (let ((val (funcall fn (car lst)) ))
                    (if val 
                      (cons val 
                            (rec fn (cdr lst)))
                      (rec fn (cdr lst)))))))
    (rec fn lst)))
; tail recursive version of filter                  
(defun filter-tr (fn lst)
  (labels ((rec (fn lst acc)
                (if lst
                  (let ((val (funcall fn (car lst)) ))
                    (if val 
                      (rec fn (cdr lst) (push val acc))
                      (rec fn (cdr lst) acc)))
                  acc)))
    (nreverse (rec fn lst nil))))

;Page 47; Utilities on List - group
(defun group (lst n)
  (if (zerop n) (error "zero length"))
  (labels ((rec (lst n acc)
                (if (null lst)
                  acc
                  (rec (nthcdr n lst) 
                       n
                       (if (> (length lst) n)
                         (push (subseq lst 0 n) acc)
                         (push lst acc))))))
    (nreverse (rec lst n nil))))
                       

;;Page 49; Utilities - flatten - flatten a tree. 
(defun flatten (tree)
  (cond ((null tree) nil)
        ((atom tree) (list tree))
        ((atom (car tree)) (cons (car tree) (flatten (cdr tree))))
        (t (nconc (flatten (car tree)) (flatten (cdr tree))))))

;tail recursive function - PG's version
(defun flatten-tr (tree)
  (labels ((rec (tree acc)
                (cond ((null tree) acc)
                      ((atom tree) (cons tree acc))
                      (t (rec (car tree) (rec (cdr tree) acc))))))
    (rec tree nil)))

;;Page 49; Utilities - prune 
;This is double test car/cdr recursion template.
;The cons and remove are the augmenting functions. 
;This is not a tail recursive function.
(defun prune (fn tree)
  (cond ((null tree) nil)
        ((atom tree) (if (funcall fn tree) nil tree))
        (t (let ((p1 (prune fn (car tree)))
                 (p2 (prune fn (cdr tree))))
            (remove nil (cons p1 p2)))))) 
                 
;Tail -recursive version - on basis of PG's version
(defun prune--tr (fn tree)
  (labels ((rec (tree acc)
              (cond ((null tree) (nreverse acc))
                    ((atom (car tree)) (rec (cdr tree) 
                                            (if (funcall fn (car tree)) 
                                              acc 
                                              (cons (car tree) acc))))
                    (t (rec (cdr tree) 
                            (cons (rec (car tree) nil) acc))))))
    (rec tree nil)))

;;Page 50; Utilities -before
(defun before (e1 e2 lst &key (test #'eql))
  (cond ((null lst) nil)
        ((funcall test (car lst) e1) lst)
        ((funcall test (car lst) e2) nil)
        (t (before e1 e2 (cdr lst) :test test))))
;Page 50; after
(defun after (e1 e2 lst &key (test #'eql))
  (and lst 
       (cond ((funcall test e2 (car lst)) (before e1 nil (cdr lst) :test test))
             ((funcall test e1 (car lst)) nil)
             (t (after e1 e2 (cdr lst) :test test)))))

;Page 50; duplicate
(defun duplicate (e1 lst &key (test #'eql))
  (let ((rest (member e1 lst  :test test)))
    (and rest (member e1 (cdr rest) :test test))))

;Page 50; split-if
(defun split-if (lst fn &optional acc)
  (cond ((null lst) nil)
        ((funcall fn (car lst)) (split-if (cdr lst) fn acc))
        (t (values (cons (car lst) acc) (split-if (cdr lst) fn acc))))) 

;Page 52 - most - call fn on each element and returns the one which scores the most
;and the max score. 
(defun most (fn lst)
  (labels ((rec (lst el scr)
                (if (null lst)
                  (values el scr)
                  (let ((val (funcall fn (car lst))))
                    (if (> val scr)
                      (rec (cdr lst) (car lst) val)
                      (rec (cdr lst) el scr))))))
    (rec (cdr lst) (car lst) (funcall fn (car lst)))))

;Page 52 - best - checks all elements to find the pair which works. 
(defun best (fn lst)
  (labels ((rec (lst wins)
                (if (null lst)
                  wins
                  (if (funcall fn  wins (car lst))
                    (rec (cdr lst) wins)
                    (rec (cdr lst) (car lst))))))
    (rec (cdr lst) (car lst))))

;Page 52 - mostn - returns elements that score max and the score
(defun mostn (fn lst)
  (labels ((rec (lst el scr)
                (if (null lst)
                  (values (nreverse el) scr)
                  (let ((val (funcall fn (car lst))))
                    (if (> val scr)
                      (rec (cdr lst) (list (car lst)) val)
                      (if (= val scr)
                        (rec (cdr lst) (push (car lst) el) scr)
                        (rec (cdr lst) el scr)))))))
    (rec (cdr lst) (list (car lst)) (funcall fn (car lst)))))

;Page 54 - mapa-b 
(defun mapa-b (fn a b &optional (inc 1))
  (labels ((rec (a acc)
                (if (> a b)
                  (nreverse acc)
                  (let ((val (funcall fn a)))
                    (rec (+ a inc) (push val acc))))))
    (rec a  nil)))

;Page 54 - map0-n
(defun map0-n (fn n)
  (mapa-b fn 0 n))

;Page 54 - map1-n
(defun map1-n (fn n)
  (mapa-b fn 1 n))

;Page 54 - map->
(defun map-> (fn a endFn stepfn)
  (labels ((rec (a acc)
                (if (funcall endFn a)
                  (nreverse acc)
                  (let ((val (funcall fn a)))
                    (rec (funcall stepfn a) (push val acc))))))
    (rec a nil)))

(defun mapa-b1 (fn a b &optional (step 1))
  (map-> fn
         a
         #'(lambda (x) (> x b))
         #'(lambda (x) (+ x step))))

;Page 54 - mappend
; A non-destructive mapcan
(defun mappend (fn &rest lists)
  (apply #'append (mapcar fn lists)))

;Page 53 - mapcars
(defun mapcars (fn &rest lists)
  (labels ((rec (lists acc)
                (if (null lists)
                  (nreverse acc)
                  (rec (cdr lists) (nconc acc 
                                          (mapcar fn (car lists)))))))
    (rec (cdr lists) (mapcar fn (car lists)))))

;Page 54; rmapcar
(defun rmapcar (fn &rest lists)
  (cond ((position nil lists) nil)
        ((atom (caar lists)) (cons (apply fn (mapcar #'car lists))
                                   (apply #'rmapcar fn (mapcar #'cdr lists))))
        (t (cons (apply #'rmapcar fn (mapcar #'car lists))
                 (apply #'rmapcar fn (mapcar #'cdr lists))))))

;Page 54 - rmapcar2 ; PG's version
(defun rmapcar2 (fn &rest lists)
  (if (some #'atom lists)
    (apply fn lists)
    (apply #'mapcar
           #'(lambda (&rest args)
               (apply #'rmapcar2 fn args))
           lists)))

;Page 56 - readlist - I/O utility
(defun readlist ()
  (let ((str (read-line)))
    (labels ((rec (n acc)
                   (multiple-value-bind (val n1) 
                                        (read-from-string str nil nil :start n)
                     (if (null val)
                       (nreverse acc)
                       (rec n1 (push val acc))))))
      (rec 0 nil))))

;Page 56 - readlist - PG's version which utilizes 
;(read-from-string) in a better way
(defun readlist2 (&rest args)
  (values (read-from-string
            (concatenate 'string 
                         "("
                         (apply #'read-line args)
                         ")"))))

;Page 56 - prompt 
(defun prompt (&rest args)
  (apply #'format *query-io* args)
  (read *query-io*))

;Page 56 - break-loop 
(defun break-loop (fn1 fn2 &rest str)
  (let ((val (apply #'prompt str)))
    (if (not (funcall fn2 val))
      (progn 
        (format *query-io*  "~A~%" (funcall fn1 val))
        (break-loop fn1 fn2 str)))))

(defun break-loop2 (fn quit &rest args)
  (format *query-io* "Entering break loop ~%")
  (loop 
    (let ((in (apply #'prompt args)))
      (if (funcall quit in)
        (return)
        (format *query-io* "~A~%" (funcall fn in))))))
      
;Page 58 
(defun mkstr (&rest args)
  (apply #'concatenate 'string (mapcar #'values args)))
